!  First process on the CRSP Compustat - merged data created with SAS
!    In this job all I want to do is identify all cases where there are multiple permnos corresponding to 1 permco.
IMPLICIT NONE
INTEGER, DIMENSION(250000) :: NOBS,PERMNO,PERMCO,FUI
DOUBLE PRECISION, DIMENSION(1100) :: VWRETD,VWRETX,EWRETD,EWRETX,SPRTN,CRSVAL
INTEGER, DIMENSION(1100) :: MDATE,CRSKNT
DOUBLE PRECISION :: R,DR,DIV,at,lt,l1,p1,p2,up,tax,compso,S,PRC,BV
INTEGER :: P,PC,D,SC,M,NP,DDD,lp,TM,IM,NG,errcod,i,status,ntc,gv,C,fyr
INTEGER :: LD,ND,ncomd,ir,j,nm,SICCD
CHARACTER * 9 :: CUS
CHARACTER * 4 :: GAR,gar2,gar3
OPEN(unit=15, file='/Users/lamlap/BSV/2022/data/IndexInfo.csv', STATUS ='OLD',READONLY,iostat= errcod)
OPEN(unit=18, file='/Users/lamlap/BSV/2022/data/mergeSCAB22.dat', STATUS ='OLD',READONLY,iostat= errcod)
OPEN(unit= 19, file='/Users/lamlap/BSV/2022/data/MULTPNfue22.dat', STATUS='replace', iostat = errcod)
OPEN(unit= 20, file='/Users/lamlap/BSV/2022/data/EXCLUDEfueALLSIC22.dat', STATUS='REPLACE')
! A reminder of how my current codes are structured to apply BSV:
!    Each row contains the permno, date, and return (from CRSP) for that month
!         plus the characteristics applicable to that month:
!             BtM lagged 6 - 18 months
!             Size lagged 2 months
!             Momentum (12 months, lagged 2 months)
!             beta on the CRSP VWMR beta from past 60 months
!             return from the same month last year
!             average return from the same month for the past 5 years
!
!    At this point, (and especially as I'm not doing anything special with dividends and/or splits), I am simply using the
!            return directly from CRSP (in 6 significant digits).
!
!    Irregularities that we see on input:
!                                         1) Multiple permnos for 1 permco.
!                                            Compute the size by multiplying each permno's prc * shrout on CRSP, and summing up.
!                                            Keep the compustat data for the permno that has the longest match.
!                                         2) Multiple rows with the same date because of distributions.
!                                         3) Possible missing compustat data and or switch back to earlier compustat date because of
!                                            change in fiscal year end.
!
!   Read in the master calendar and index file. Month 1 is Jan 1955.
!
!   In this code I want to accomplish 2 things:
!                                             1) Identify all cases where there are multiple permnos for a single permco.
!                                                Write both into a file for processing at the next step.
!                                             2) Identify all cases with less than 50 observations and write those permnos so
!                                                that they can be deleted at the next step.  NB It's possible that they can't
!                                                be ignored if there is a permco match for them.
NG=349
READ (15,*) GAR
DO i=1,NG
   READ (15,*)GAR
END DO
IM=0
DO 
   IM=IM+1
   READ (15,*,iostat=status) MDATE(IM),VWRETD(IM),VWRETX(IM),EWRETD(IM),ewretx(IM),SPRTN(IM),gar2,gar3,CRSVAL(IM),CRSKNT(IM)
   IF(status .ne. 0)  EXIT
!    IF (IM==1) PRINT 1566, IM,MDATE(IM); 1566 format (2x,i3,3x,i8)
END DO
TM=IM-1
PRINT 54, TM; 54 format (' TM = ',i4)
LP=0
NTC=0
DO i=1,25000
   NOBS(i)=0
END DO
DO 
   READ (18,1866,iostat=status) P,PC,D,R,PRC,S,SICCD,DDD,BV
      IF (status /= 0) EXIT
   1866 format (2(i5,1x),i8,1x,f11.6,1x,f14.5,1x,i10,2x,i4,1x,i8,1x,f14.5)
!                1     2     3      4        5        6     7     8     9    10    11    12    13   14 - 20
        IF (P/=LP) THEN
           LP=P 
           IF (NTC/=0) THEN
              NOBS(NTC)=ir
              PRINT 6576, NTC,PERMNO(NTC),FUI(NTC),nobs(ntc); 6576 format (' ntc ',i8,' permno: ',i6,' FUI: ',i8,' nobs: ',i3)
           END IF
           NTC=NTC+1
           FUI(NTC)=0
!            IF (SICCD>=4900 .AND. SICCD<=4999) FUI(NTC)=1
!            IF (SICCD>=6000 .AND. SICCD<=6999) FUI(NTC)=1
           ir=1
           PERMNO(NTC)=P
           PERMCO(NTC)=PC
        ELSE 
           ir=ir+1
!            IF (SICCD>=4900 .AND. SICCD<=4999) FUI(NTC)=1
!            IF (SICCD>=6000 .AND. SICCD<=6999) FUI(NTC)=1
        END IF
END DO
PRINT 7685, NTC; 7685 format (' reading finished.  ',i6,' unique permnos.')
DO i=1,NTC
   NM=0
!    IF (FUI(i)==1) THEN
!       WRITE (20,2066) PERMNO(i),NOBS(i)
!       CYCLE
!    END IF
   DO j=i+1,NTC
      IF (permco(i) == permco(j)) THEN
         WRITE (19,1966) permco(i),permno(i),permno(j),NOBS(i),NOBS(j); 1966 format (5(i5,2x)) 
         NM=NM+1
      END IF
   END DO
   IF (nm == 0 .AND. NOBS(i) < 60) THEN
      WRITE (20,2066) PERMNO(i),NOBS(i); 2066 format (i5,2x,i2)
   END IF
END DO
STOP; END
